home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 February: Tool Chest / Apple Developer CD Series Tool Chest February 1996 (Apple Computer)(1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / Think C interface / think-c.lisp < prev    next >
Encoding:
Text File  |  1994-09-12  |  7.2 KB  |  244 lines  |  [TEXT/CCL2]
  1. ;;; -*- Mode: LISP; Package: THINK-C; Syntax: Common-lisp; Base: 10; -*-
  2. ;;; Thr Nov 14 1991 by Guillaume Cartier <cartier@math.uqam.ca>
  3. ;;; think-c.lisp
  4. ;;;
  5. ;;; *****************************************************************
  6. ;;; General License Agreement and Lack of Warranty ******************
  7. ;;; *****************************************************************
  8. ;;;
  9. ;;; This software is distributed in the hope that it will be useful (both
  10. ;;; in and of itself), but WITHOUT ANY WARRANTY. The author does not accept
  11. ;;; responsibility to anyone for the consequences of using it or for whether
  12. ;;; it serves any particular purpose or works at all. No warranty is made
  13. ;;; about the software or its performance.
  14. ;;;
  15. ;;; The current version of this software may be obtained by anonymous ftp
  16. ;;; from cambridge.apple.com in the directory pub/MCL/CONTRIB.
  17. ;;;
  18. ;;; Please send bug reports, comments, questions and suggestions to
  19. ;;; cartier@math.uqam.ca. I would also appreciate receiving any changes
  20. ;;; or improvements you may make.
  21. ;;;
  22. ;;; *****************************************************************
  23. ;;; ThinkC interface ************************************************
  24. ;;; *****************************************************************
  25. ;;;
  26. ;;; This ThinkC interface consist of some lisp files and C header
  27. ;;; files, enabling one to easily use ThinkC functions in MCL. An
  28. ;;; example is also provided.
  29. ;;;
  30. ;;; Very special thanks to the MCL team, they have always been very
  31. ;;; generous of their time in responding promptly to any questions I had.
  32. ;;;
  33. ;;; *****************************************************************
  34. ;;; Revision History ************************************************
  35. ;;; *****************************************************************
  36. ;;;
  37. ;;; 25/01/91   - Posted the code for the first time at cambridge.
  38. ;;; 14/11/91   - Converted the code to MCL2.0b1.
  39. ;;;
  40.  
  41.  
  42. (require :ff)
  43. (provide :think-c)
  44.  
  45. (defpackage "THINK-C"
  46.   (:use "COMMON-LISP" "CCL")
  47.   (:import-from "CCL" "DEF-MACTYPE" "MAKE-MACTYPE" "%VREFLET")
  48.   (:export "*THINK-C-FOLDER*"
  49.            "DEFCMODULE"
  50.            "DEFAULT-RESOURCE-FILE"
  51.            "LOAD-CMODULE"
  52.            "CLOSE-CMODULE"
  53.            "%ALLOCATE-DOUBLE"
  54.            "%MAKE-DOUBLE"
  55.            "%GET-DOUBLE"
  56.            "%PUT-DOUBLE"))
  57.  
  58. (in-package "THINK-C")
  59.  
  60.  
  61. ;;; ***********************
  62. ;;; Global stuff **********
  63. ;;; ***********************
  64.  
  65.  
  66. (defvar *THINK-C-FOLDER*
  67.   "think-c:")
  68.  
  69. (defvar *CMODULE-RESOURCE-TYPE*
  70.   "TCCD")
  71.  
  72. (defvar *CMODULES-TABLE*
  73.   (make-hash-table))
  74.  
  75. (defvar *CMODULES*
  76.   nil)
  77.  
  78.  
  79. (defstruct CMODULE
  80.   name
  81.   variables
  82.   functions
  83.   resource-file
  84.   refnum)
  85.  
  86.  
  87. (defun GET-CMODULE (module-name)
  88.   (or (gethash module-name *cmodules-table*)
  89.       (error "Unknown C module ~a ." module-name)))
  90.  
  91.  
  92. ;;; *****************************
  93. ;;; CModule definition **********
  94. ;;; *****************************
  95.  
  96.  
  97. (defmacro DEFCMODULE (name &key variables functions
  98.                                   (resource-file (default-resource-file name)))
  99.   `(progn
  100.      (defvar ,name)
  101.      (setf (gethash ',name *cmodules-table*)
  102.            (make-cmodule
  103.             :name          ',name
  104.             :variables     ',variables
  105.             :functions     ',(mapcar (function car) functions)
  106.             :resource-file ,resource-file))
  107.      (pushnew ',name *cmodules*)
  108.      ,@(mapcar (function
  109.                  (lambda (symb)
  110.                    `(defvar ,symb)))
  111.                variables)
  112.      ,@(mapcan (function
  113.                  (lambda (spec)
  114.                    (apply (function expand-function-spec)
  115.                           (cons name spec))))
  116.                functions)
  117.      ',name))
  118.  
  119.  
  120. (defun EXPAND-FUNCTION-SPEC (loader symb argstype &optional restype)
  121.   (let* ((args     (loop for arg in argstype
  122.                          collect (if (keywordp arg)
  123.                                      (copy-symbol arg)
  124.                                    (intern (write-to-string arg)))))
  125.          (lispargs (loop for x in argstype for y in args
  126.                          for type = (if (keywordp x) x (second x))
  127.                          when (eq type :lisp) collect y)))
  128.     (list
  129.      `(defvar ,symb)
  130.      `(defun ,symb ,args
  131.         (%vreflet ,(mapcar (function list) lispargs lispargs)
  132.           (ff-call ,symb :a4 ,loader
  133.                    ,@(loop for x in (reverse args)
  134.                            collect :ptr collect x)
  135.                    ,(or restype :novalue)))))))
  136.  
  137.  
  138. (defun DEFAULT-RESOURCE-FILE (name)
  139.   (merge-pathnames
  140.     *think-c-folder*
  141.     (symbol-name name)))
  142.  
  143.  
  144. ;;; *********************
  145. ;;; The loader **********
  146. ;;; *********************
  147.  
  148.  
  149. (defun LOADER-IMPORT (loader symb)
  150.   (with-pstrs ((str (symbol-name symb)))
  151.     (let ((add (ff-call loader :a4 loader :ptr str :a0)))
  152.       (if (%null-ptr-p add)
  153.           (error "Undefined C function ~a ." symb)
  154.         (set symb add)))))
  155.  
  156.  
  157. (defun LOAD-CMODULE (module-name)
  158.   (let ((module (get-cmodule module-name)))
  159.     (setf (cmodule-refnum module)
  160.           (open-resource-file (truename (cmodule-resource-file module))))
  161.     (let ((res (get-resource *cmodule-resource-type* (symbol-name module-name))))
  162.       (cond
  163.         ((null res)
  164.          (error "Can't find the C module ~a ." module-name))
  165.         (t (#_DetachResource res)
  166.            (let ((loader (%get-ptr res)))
  167.              (set module-name loader)
  168.              (dolist (symb (cmodule-variables module)) (loader-import loader symb))
  169.              (dolist (symb (cmodule-functions module)) (loader-import loader symb))))))))
  170.  
  171.  
  172. (defun CLOSE-CMODULE (module-name)
  173.   (close-resource-file
  174.     (cmodule-refnum (get-cmodule module-name))))
  175.  
  176.  
  177. (def-load-pointers RESTORE-CMODULES ()
  178.   (dolist (cmodule *cmodules* t)
  179.     (apply (function load-cmodule) cmodule)))
  180.  
  181.  
  182. ;;; ***************************
  183. ;;; ThinkC's doubles **********
  184. ;;; ***************************
  185.  
  186.  
  187. (defun (setf %GET-DOUBLE) (data pointer &optional (offset 0))
  188.   (%put-double pointer data offset))
  189.  
  190.  
  191. (defun %ALLOCATE-DOUBLE ()
  192.   (#_NewPtr 12))
  193.  
  194. (defun %MAKE-DOUBLE (float)
  195.   (let ((ptr (%allocate-double)))
  196.     (setf (%get-double ptr) float)
  197.     ptr))
  198.  
  199.  
  200. (defun %GET-DOUBLE (pointer &optional (offset 0))
  201.   (let ((ptr (%inc-ptr pointer offset)))
  202.     (%put-word ptr (%get-word ptr) 2)
  203.     (ccl::%get-x2float (%inc-ptr ptr 2))))
  204.  
  205. (defun %PUT-DOUBLE (pointer float &optional (offset 0))
  206.   (let ((ptr (%inc-ptr pointer offset)))
  207.     (ccl::%float2x (float float) (%inc-ptr ptr 2))
  208.     (%put-word ptr (%get-word ptr 2))))
  209.  
  210.  
  211. ;;
  212. ;; If you're using MCL2.0b3 or upwards, you can use the following
  213. ;; definition to ease working with doubles. In fact, you could probably
  214. ;; use it also in MCL2.0b1 with small changes (MCL2.0b1 does'nt recognize
  215. ;; the :access-operator keyword option to DEF-MACTYPE).
  216. ;;
  217.  
  218. (unless (search "2.0b1" (lisp-implementation-version))
  219.  
  220.   (def-mactype :DOUBLE
  221.     (make-mactype
  222.      :name            :double
  223.      :record-size     12
  224.      :access-operator '%get-double)))
  225.  
  226.  
  227. ;;; **************************
  228. ;;; Resources stuff **********
  229. ;;; **************************
  230.  
  231.  
  232. (defun OPEN-RESOURCE-FILE (file)
  233.   (with-pstrs ((pf (mac-namestring (truename file))))
  234.     (#_OpenResFile pf)))
  235.  
  236. (defun CLOSE-RESOURCE-FILE (refnum)
  237.   (#_CloseResFile refnum))
  238.  
  239.  
  240. (defun GET-RESOURCE (type name)
  241.   (let ((res (with-pstrs ((ps name))
  242.                (#_GetNamedResource type ps))))
  243.     (unless (%null-ptr-p res) res)))
  244.